home *** CD-ROM | disk | FTP | other *** search
/ Gekikoh Dennoh Club 5 / Gekikoh Dennoh Club Vol. 5 (Japan).7z / Gekikoh Dennoh Club Vol. 5 (Japan) (Track 01).bin / docs / rakup / expret.vl next >
Encoding:
Text File  |  1998-10-03  |  7.3 KB  |  301 lines
  1. ;
  2. ; EXPERT.VL : Prolog òùâGâLâXâpü[âgâVâXâeâÇ
  3. ;
  4. ; ô┴ÆÑ
  5. ;   âpâ^ü[âôâ}âbâ`âôâOü{âoâbâNâgâëâbâNé╠é▌
  6. ;   Prolog é¬ö⌡éªé─éóéΘægé▌ì₧é▌ÅqîΩé═Ä└æòé╡é─éóé╚éó
  7. ;   ïKæÑé═æ«É½âèâXâg RULE é╔âZâbâgé╖éΘ
  8. ;   ò╧Éöé═ gensym é≡Ägé┴é─âRâsü[
  9. ;   É▀é≡âRâsü[é╖éΘé╠é┼Ä└ìsæ¼ôxé═Æxéó
  10. ;   Ælé═âXâyâVâââïò╧Éöé╔èiö[é╖éΘüiæ⌐ö¢âèâXâgé═Ägéφé╚éóüj
  11. ;
  12. ;               Copyright (C) 1998 by Makoto Hiroi
  13. ;
  14.  
  15. ;
  16. ; ********** É▀é╠ÆΦï` **********
  17. ;
  18. (defclass Rule ()
  19.   (var-list         ; ò╧ÉöâèâXâg
  20.    clause))         ; É▀
  21.  
  22. ;
  23. ; É▀é≡âRâsü[é╖éΘüiò╧Éöé═ gensym é┼Æuè╖é│éΩéΘüj
  24. ;
  25. (defmethod copy-clause ((r Rule))
  26.   (with-slots (var-list clause) r
  27.     (sublis
  28.       (if var-list
  29.           (mapcar #'(lambda (var) (cons var (gensym))) var-list))
  30.       clause)))
  31.  
  32. ;
  33. ; Rule é≡ì∞éΘ
  34. ;
  35. (defun make-rule (clause)
  36.   (make-instance 'Rule 
  37.                  'var-list (collect-variable clause nil)
  38.                  'clause clause))
  39.  
  40. ;
  41. ; É▀é╠ôoÿ^ clause := ((predicate args ... ) ... )
  42. ;          predicate ÅqîΩé═âVâôâ{âï
  43. ;
  44. (defun assert (clause)
  45.   (check-clause clause)
  46.   (let ((predicate (car (car clause))))
  47.     (putprop predicate
  48.              (cons (make-rule clause)
  49.                    (get predicate 'RULE))
  50.              'RULE)))
  51.  
  52. ;
  53. ; É▀é╠â`âFâbâN
  54. ;
  55. (defun check-clause (clause)
  56.   (dolist (x clause)
  57.     (if (or (variablep (car x))
  58.             (not (symbolp (car x))))
  59.         (error "É▀é╔ÅqîΩé¬éáéΦé▄é╣é± ~A\n" clause))))
  60.  
  61. ;
  62. ; âfü[â^é╠âìü[âh : ((p ...) ... ) é╠î`Ä«
  63. ;
  64. (defun load-data (filename)
  65.   (let (clause)
  66.     (with-open-file (in filename "r")
  67.       (while (setq clause (read in nil))
  68.         (assert clause)))))
  69.  
  70. ;
  71. ; Ä┐ûΓé╖éΘ
  72. ;
  73. (defun Q (question)
  74.   (let* ((rule (make-rule question))
  75.          (env  (make-env (slot-value rule 'clause)))
  76.          result)
  77.     (while (listp (setq result (exec-clause env)))
  78.       (dolist (var (slot-value rule 'var-list) (terpri))
  79.         (format t "~A = ~A\n" var (variable-value var))))))
  80.  
  81.  
  82. ;
  83. ; ********** Ä└ìsè┬ï½é╠ÆΦï` **********
  84. ;
  85. (defclass Env ()
  86.   (goal                 ; âSü[âïÉ▀
  87.    rule-list            ; ÅqîΩé╔ÆΦï`é│éΩé─éóéΘïKæÑ
  88.    exec-rule            ; Ä└ìsÆåé╠ïKæÑ
  89.    exec-env             ; ì∞ɼé╡é╜è┬ï½üiâXâ^âbâNé╔é╚éΘüj
  90.    binding))            ; æ⌐ö¢é╡é╜ò╧Éö
  91.  
  92.  
  93. ;
  94. ; Ä└ìsè┬ï½é╠ì∞ɼ
  95. ;
  96. (defun make-env (pattern)
  97.   (make-instance 'Env
  98.                  'goal      pattern
  99.                  'rule-list (get (car pattern) 'RULE)
  100.                  'binding   'call))
  101.  
  102. ;
  103. ; É▀é╠Ä└ìs
  104. ;
  105. (defmethod exec-clause ((e Env))
  106.   (with-slots (rule-list binding) e
  107.     (let ((result 'fail))
  108.       (if (eq binding 'call)
  109.           ; ì┼Åëé╠î─é╤Åoé╡
  110.           (if rule-list
  111.               (setq result (select-rule e)))
  112.           ; ì─ÄÄìs
  113.           (if (eq 'fail (setq result (exec-body e)))
  114.               ; Äƒé╠É▀é≡Ä└ìs
  115.               (setq result (select-rule e))))
  116.       (if (eq result 'fail)
  117.           (clear-binding binding)
  118.           result))))
  119.  
  120. ;
  121. ; ô¬òöé╞Å╞ìçé╖éΘïKæÑé≡æIæ≡
  122. ;
  123. (defmethod select-rule ((e Env))
  124.   (with-slots (exec-rule exec-env) e
  125.     (let ((result 'fail))
  126.       (while
  127.         (and (listp (setq result (unify-head e)))
  128.              exec-rule)
  129.         (push (make-env (car exec-rule)) exec-env)
  130.         (if (listp (setq result (exec-body e)))
  131.             (return)))
  132.       result)))
  133.  
  134. ;
  135. ; ô¬òöé╞é╠âåâjâtâBâPü[âVâçâô
  136. ;
  137. (defmethod unify-head ((e Env))
  138.   (with-slots (goal rule-list exec-rule binding) e
  139.     (let ((result 'fail) now-rule)
  140.       ; æ⌐ö¢ò╧Éöé¬éáéΩé╬âNâèâAé╖éΘ
  141.       (clear-binding binding)
  142.       (while rule-list            ; ïKæÑé¬éáéΘè╘îJéΦò╘é╖
  143.     ; É▀é≡âRâsü[é╖éΘ
  144.         (setq now-rule (copy-clause (pop rule-list)))
  145.         (when
  146.           ; goal é╞ head é╠Å╞ìç
  147.           (listp (setq result (unify goal (pop now-rule) nil)))
  148.           ; É¼î≈ : É▀é≡Æuè╖é╡æ⌐ö¢é│éΩé╜ò╧Éöé≡ïLë»é╖éΘ
  149.           (setq exec-rule now-rule
  150.                 binding   result)
  151.           (return)))
  152.       result)))                  ; îïë╩é≡Åoù═é╖éΘ
  153.  
  154.  
  155. ;
  156. ; æ╠òöé╠Ä└ìs
  157. ;
  158. (defun exec-body (env)
  159.   (with-slots (exec-env exec-rule) env
  160.     (let ((max-state (length exec-rule))
  161.           (result 'fail)
  162.           now-state)
  163.       ; Ä└ìsè┬ï½é¬é╚é¡é╚éΘé▄é┼îJéΦò╘é╖
  164.       (while exec-env
  165.         (setq result (exec-clause (car exec-env)))
  166.         (cond
  167.           ; Å╞ìçÄ╕ösé═âoâbâNâgâëâbâNé╖éΘüB
  168.           ((eq 'fail result)
  169.            (pop exec-env))
  170.           ; æSé─é╠â}âbâ`âôâOé╔ɼî≈
  171.           ((= max-state (setq now-state (length exec-env)))
  172.            (return))
  173.           ; Å╞ìçɼî≈é═ăé╠É▀é╔Éié▐
  174.           (t (push (make-env (elt exec-rule now-state)) exec-env))))
  175.  
  176.       ; îïë╩é≡Åoù═é╖éΘ
  177.       result)))
  178.  
  179.  
  180.  
  181. ;
  182. ; ********** Å╞ìçè╓Éö **********
  183. ;
  184. ; OUTPUT -- Ä╕ös : fail, É¼î≈ : æ⌐ö¢é╡é╜âVâôâ{âï
  185. ;
  186. (defun unify (pattern datum binding)
  187.   (cond ((variablep pattern)
  188.          (unify-variable pattern datum binding))
  189.         ((variablep datum)
  190.      (unify-variable datum pattern binding))
  191.         ((and (atom pattern) (atom datum))
  192.          (unify-atoms pattern datum binding))
  193.         ((and (consp pattern) (consp datum))
  194.          (unify-pieces pattern datum binding))
  195.         (t (clear-binding binding))))
  196.  
  197. ;
  198. ; âAâgâÇé╞é╠âåâjâtâBâPü[âVâçâô
  199. ;
  200. (defun unify-atoms (pattern datum binding)
  201.   (if (equal pattern datum)
  202.       binding
  203.       (clear-binding binding)))
  204.  
  205. ;
  206. ; âèâXâgé╠âåâjâtâBâPü[âVâçâô
  207. ;
  208. (defun unify-pieces (pattern datum binding)
  209.   (let ((result (unify (car pattern) (car datum) binding)))
  210.     (if (eq result 'fail)
  211.         'fail
  212.         (unify (cdr pattern) (cdr datum) result))))
  213.  
  214. ;
  215. ; ò╧Éöé╞é╠âåâjâtâBâPü[âVâçâô
  216. ;
  217. (defun unify-variable (var datum binding)
  218.   (if (and (boundp var)
  219.            (not (eq (symbol-value var) var)))       ; Ä⌐ò¬Ä⌐Égé┼é═é╚éó
  220.       (unify (symbol-value var) datum binding)
  221.       (add-binding var datum binding)))             ; insidep é╠â`âFâbâNé═òsùv
  222.  
  223. ;
  224. ; ********** âTâuâïü[â`âô **********
  225. ;
  226.  
  227. ;
  228. ; ò╧Éöé≡â`âFâbâNé╖éΘ
  229. ; 
  230. (defun variablep (pattern)
  231.   (and (symbolp pattern)
  232.        (upper-case-p (char pattern 0))))
  233.  
  234. ;
  235. ; ò╧ÉöÆlé≡âZâbâgé╖éΘ
  236. ;
  237. (defun add-binding (var datum binding)
  238.   (set var datum)
  239.   (cons var binding))
  240.  
  241. ;
  242. ; ò╧Éöé≡âNâèâAé╡é─ 'fail é≡ò╘é╖
  243. ;
  244. (defun clear-binding (binding)
  245.   (if (listp binding)
  246.     (dolist (var binding) (makunbound var)))
  247.     'fail)
  248. ;
  249. ; É▀é┼Ägùpé│éΩé─éóéΘò╧Éöé≡ÅWé▀éΘ
  250. ;
  251. (defun collect-variable (clause var-list)
  252.   (cond
  253.     ((variablep clause)
  254.      (pushnew clause var-list))
  255.     ((atom clause) var-list)
  256.     (t
  257.       (collect-variable
  258.         (cdr clause)
  259.         (collect-variable (car clause) var-list)))))
  260.  
  261.  
  262. ;
  263. ; ò╧Éöé≡Æuè╖é╖éΘ
  264. ;
  265. (defun replace-variable (pattern)
  266.   (cond
  267.     ((variablep pattern)
  268.      (variable-value pattern))
  269.     ((atom pattern) pattern)
  270.     (t
  271.      (cons (replace-variable (car pattern))
  272.            (replace-variable (cdr pattern))))))
  273.  
  274. ;
  275. ; ò╧ÉöÆlé≡ïüé▀éΘ
  276. ;
  277. (defun variable-value (var)
  278.   (let (value)
  279.     (loop
  280.       (unless (boundp var) (return var)) ; ûóæ⌐ö¢
  281.       (setq value (symbol-value var))    ; âXâyâVâââïò╧Éöé≡ĵéΦÅoé╖
  282.       (cond
  283.         ((eq var value)    
  284.          (return value))                 ; Ä⌐ò¬Ä⌐Égé¬ôⁿé┴é─éóéΘ
  285.         ((variablep value)
  286.          (setq var value))
  287.         ((consp value)                   ; Æåé╔ò╧Éöé¬éáéΘé⌐éαé╡éΩé╚éóé╠é┼Æuè╖é╖éΘ
  288.      (return (replace-variable value)))
  289.         (t (return value))))))
  290.  
  291. ; âeâXâg
  292. ; âfü[â^é╠âìü[âh
  293. ;
  294. ;(load-data "list.dat")
  295. ;
  296. ; Ä└ìsùß
  297. ;(Q '(perm (a b c) Y))
  298. ;
  299.  
  300. ; end of file
  301.